home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / PGM_TOOL / RESOURCE / RESOURCE.PAS < prev    next >
Pascal/Delphi Source File  |  1992-09-14  |  9KB  |  362 lines
  1. program Resource;
  2.  
  3. {$R Resource.RES}
  4.  
  5. uses WObjects, WinTypes, WinProcs, Strings, Frames, BWcc, StdDlgs;
  6.  
  7. function GetHeapSpaces(Handle:THandle):longint; far; external 'KERNEL';
  8.  
  9. const
  10.     sc_About=100;
  11.     sc_Options=101;
  12.     id_ed1 = 201;
  13.     id_ed2 = 202;
  14.     id_ed3 = 203;
  15.     id_Default = 205;
  16.     GDILen = 2;
  17.     USRLen = 2;
  18.     MemLen = 5;
  19.  
  20. var
  21.   R:TRect;
  22.   PctTxt1:array[0..4] of Char; {GDI heap free}
  23.   PctTxt2:array[0..4] of Char; {User heap free}
  24.   PctTxt3:array[0..4] of Char; {Memory free}
  25.     GDIMin : array[0..GDILen] of Char;
  26.       USRMin : array[0..USRLen] of Char;
  27.     MemMin : array[0..MemLen] of Char;
  28.  
  29.   InitMem:longint;
  30.   size     :integer;
  31.  
  32. type
  33.   PDialogRec = ^DialogRec;
  34.   DialogRec = record
  35.   end;
  36.  
  37.       PEdDialog = ^EdDialog;
  38.     EdDialog = object(TDialog)
  39.       DataPointer: PDialogRec; 
  40.       constructor Init (AParent: PWindowsObject; AName: PChar;
  41.         P: PDialogRec);
  42.       procedure SetupWindow; virtual;
  43.       procedure Ok(var Msg: TMessage);
  44.         virtual id_first + id_ok;
  45.       procedure Default(var Msg: TMessage);
  46.         virtual id_first + id_Default;
  47.     end;
  48.  
  49.     TResourceApp = Object(TApplication)
  50.       procedure InitMainWindow; virtual;
  51.     end;
  52.  
  53.     PResourceWindow = ^TResourceWindow;
  54.     TResourceWindow = object(TWindow)
  55.         SysMenu:HMenu;
  56.         DialogData: DialogRec;
  57.         function GetClassName: PChar; virtual;
  58.         constructor Init(AParent: PWindowsObject; ATitle: PChar);
  59.         procedure SetupWindow; virtual;
  60.         procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  61.         procedure Paint(PaintDC:HDC; var PaintInfo:TPaintStruct); virtual;
  62.         procedure WMDestroy(var Msg:TMessage); virtual wm_First+wm_Destroy;
  63.         procedure About;
  64.         procedure Options;
  65.         procedure WMSysCommand(var Msg:TMessage); virtual wm_First+wm_SysCommand;
  66.         procedure WMTimer(var Msg:TMessage); virtual wm_First+wm_Timer;
  67.     end;
  68.  
  69.  
  70. {Initialize edit control}
  71. procedure SetText(HDlg: HWnd; CtrlID: Word; Buffer: PChar; MaxLen: Word);
  72. begin
  73.   SendDlgItemMessage(HDlg, CtrlID, wm_SetText, 0, LongInt(Buffer));
  74.   SendDlgItemMessage(HDlg, CtrlID, em_LimitText, MaxLen, 0);
  75. end;
  76.  
  77. { Retieve Text}
  78. procedure GetText(HDlg: HWnd; CtrlID: Word; Buffer: PChar; MaxLen: Word);
  79. begin
  80.   SendDlgItemMessage(HDlg, CtrlID, wm_GetText, MaxLen, LongInt(Buffer));
  81. end;
  82.  
  83. constructor EdDialog.Init(AParent: PWindowsObject; AName: PChar;
  84.   P: PDialogRec);
  85.  
  86. begin
  87.   TDialog.Init(AParent, AName);
  88.   DataPointer := P;
  89. end;
  90.  
  91.  
  92. function TResourceWindow.GetClassName: PChar;
  93. begin
  94.     GetClassName := 'ResourceWindow'
  95. end;
  96.  
  97. procedure TResourceWindow.GetWindowClass(var AWndClass: TWndClass);
  98. begin
  99.     TWindow.GetWindowClass(AWndClass);
  100.     AWndClass.HIcon := 0;
  101. end;
  102.  
  103. procedure EdDialog.SetupWindow;
  104. var
  105.   I: Integer;
  106.  
  107. begin
  108.   TDialog.SetupWindow;
  109.   with DataPointer^ do
  110.   begin
  111.     SetText(HWindow, id_Ed1, GDIMin, GDILen);
  112.     SetText(HWindow, id_Ed2, USRMin, USRLen);
  113.     SetText(HWindow, id_Ed3, MemMin, MemLen);
  114.   end;
  115. end;
  116.  
  117. procedure TResourceWindow.SetupWindow;
  118. var T:longint;
  119.     wout:boolean;
  120.     LogicFont:HFont;
  121.     PaintDC:HDC;
  122.     I: integer;
  123.  
  124. begin
  125.     TWindow.SetupWindow;
  126.     if SetTimer(HWindow,20,500,nil)=0 then  {timer set for 1/2 second}
  127.     begin
  128.         MessageBox(HWindow,'Cannot start timer for',
  129.                              'Resource Monitor',mb_IconStop or mb_OK);
  130.         CloseWindow;
  131.     end;
  132.     UpdateWindow(HWindow);
  133.     SysMenu:=GetSystemMenu(HWindow,false);
  134.     size:=10;
  135.     wout:=true;
  136.      PaintDC:=GetDC(HWindow);
  137.     while wout do
  138.     begin
  139.         LogicFont := CreateFont(size,0,0,0,900,0,0,0,0,0,0,0,ff_Swiss+Variable_Pitch,'MS Sans Serif');
  140.         SelectObject(PaintDC,LogicFont);
  141.         If Loword(GetTextExtent(PaintDC,'100%',4))<(GetSystemMetrics(sm_CXIcon)) then wout:=false
  142.         else size:=size-1;
  143.     DeleteObject(LogicFont);
  144.     end;
  145.   ReleaseDC(HWindow,PaintDC);
  146.   if (size*3) > Round(GetSystemMetrics(sm_CYIcon)*0.65) then
  147.     size := Round(GetSystemMetrics(sm_CYIcon)*0.45);
  148.     DeleteMenu(SysMenu,sc_Restore,mf_ByCommand);
  149.     DeleteMenu(SysMenu,sc_Maximize,mf_ByCommand);
  150.     AppendMenu(SysMenu,mf_String,0,nil);
  151.     AppendMenu(SysMenu,mf_String,sc_About,'&About ...');
  152.     AppendMenu(SysMenu,mf_String,sc_Options,'&Options ...');
  153.     SendMessage(HWindow,wm_Timer,1,0);
  154. end;
  155.  
  156. constructor TResourceWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  157.  
  158. begin
  159.   TWindow.Init(AParent, ATitle);
  160.   with DialogData do
  161.   begin
  162.     StrCopy(GDIMin, '45');
  163.     StrCopy(USRMin, '45');
  164.     StrCopy(MemMin, '4500');
  165.   end;
  166. end;
  167.  
  168. procedure TResourceWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
  169.  
  170. var TextMetrics            : TTextMetric;
  171.     OldFont,LogicFont    : HFont;
  172.     code,Y1,Y2,Y3        : integer;
  173.     I,min                : integer;
  174.     x                    : string;
  175.  
  176. begin
  177.     with R do
  178.     begin
  179.         Right:=GetSystemMetrics(sm_CXIcon)+3;
  180.         Bottom:=GetSystemMetrics(sm_CYIcon)+3;
  181.         Left:=0;Top:=0;
  182.     end;
  183.     DrawBorderFrame(PaintDC,R,true);
  184.     LogicFont := CreateFont(size,0,0,0,900,0,0,0,0,0,0,0,ff_Swiss+Variable_Pitch,'MS Sans Serif');
  185.     OldFont:=SelectObject(PaintDC,LogicFont);
  186.     SetBkMode(PaintDC,Transparent);
  187.     SetTextAlign(PaintDC,ta_Top);
  188.     GetTextMetrics(PaintDC,TextMetrics);
  189.     Y1:=Round((R.bottom-(2*size))/2)-4;
  190.     Y2:=R.bottom-Y1-size-10;
  191.     Y3:=R.bottom-Y2-size+12;
  192.  
  193.     x:= StrPas(PctTxt1);
  194.     dec(x[0]);
  195.     val(x, I, code );
  196.     val(GDIMin,Min,code);
  197.     if I < Min then
  198.         SetTextColor(PaintDC,RGB(255,0,0))
  199.     else
  200.         SetTextColor(PaintDC,RGB(0,0,255));
  201.     TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt1,StrLen(PctTxt1))))/2),
  202.         Y1,PctTxt1,StrLen(PctTxt2));
  203.  
  204.     x:= StrPas(PctTxt2);
  205.     dec(x[0]);
  206.     val(x, I, code );
  207.     val(USRMin,Min,code);
  208.     if I < Min then
  209.         SetTextColor(PaintDC,RGB(255,0,0))
  210.     else 
  211.         SetTextColor(PaintDC,RGB(0,0,255));
  212.     TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt2,StrLen(PctTxt2))))/2),
  213.         Y2,PctTxt2,StrLen(PctTxt2));
  214.  
  215.  
  216.     val(StrPas(PctTxt3),I,code);
  217.     val(MemMin,Min,code);
  218.     if I < Min then
  219.         SetTextColor(PaintDC,RGB(255,0,0))
  220.     else
  221.         SetTextColor(PaintDC,RGB(0,0,255));
  222.     TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt3,StrLen(PctTxt3))))/2),
  223.         Y3,PctTxt3,StrLen(PctTxt3));
  224.  
  225.   SelectObject(PaintDC,OldFont);
  226.     DeleteObject(LogicFont);
  227. end;
  228.  
  229. procedure TResourceWindow.WMTimer(var Msg:TMessage);
  230. var
  231.     wFree,wSize:word;
  232.     GDIPct,UserPct,dwInfo:longint;
  233.       PctTxtT1,PctTxtT2,PctTxtT3:array[0..4] of char;
  234.     PctNum:string;
  235.  
  236. begin
  237.     dwInfo:=GetHeapSpaces(GetModuleHandle('GDI'));
  238.     wSize:=HiWord(dwInfo);
  239.     wFree:=LoWord(dwInfo);
  240.     GDIPct:=Round(wFree/wSize*100);
  241.     Str(GDIPct,PctNum);
  242.     StrPCopy(PctTxtT1,PctNum+'%');
  243.  
  244.     dwInfo:=GetHeapSpaces(GetModuleHandle('User'));
  245.     wSize:=HiWord(dwInfo);
  246.     wFree:=LoWord(dwInfo);
  247.     UserPct:=Round(wFree/wSize*100);
  248.     Str(UserPct,PctNum);
  249.     StrPCopy(PctTxtT2,PctNum+'%');
  250.  
  251.     Str(Round(MemAvail/1000),PctNum);
  252.     StrPCopy(PctTxtT3,PctNum);
  253.  
  254.     if (StrComp(PctTxt1,PctTxtT1)<>0) or (StrComp(PctTxt2,PctTxtT2)<>0) or
  255.         (StrComp(PctTxt3,PctTxtT3)<>0) or (Msg.wParam=1) then
  256.     begin
  257.         StrPCopy(PctTxt1,PctTxtT1);
  258.         StrPCopy(PctTxt2,PctTxtT2);
  259.         StrPCopy(PctTxt3,PctTxtT3);
  260.         InvalidateRect(HWindow,nil,false);
  261.         UpdateWindow(HWindow);
  262.     end;
  263. end;
  264. {- Respond to Default butoon }
  265. procedure EdDialog.Default(var Msg: TMessage);
  266.  
  267. begin
  268.     StrCopy(GDIMin, '45');
  269.     StrCopy(USRMin, '45');
  270.     StrCopy(MemMin, '4500');
  271.     TDialog.Ok(Msg);
  272. end;
  273.  
  274. {- Respond to Ok butoon }
  275. procedure EdDialog.Ok(var Msg: TMessage);
  276. const
  277.   NumSet = ['0'..'9'];
  278.  
  279. var
  280.   TGDI: Array[0..2] of Char;
  281.   TUSR: Array[0..2] of Char;
  282.   TMem: Array[0..3] of Char;
  283.   Text: Array[0..10] of Char;
  284.   I,Len : integer;
  285.   Valid : boolean;
  286.    
  287.  
  288. begin
  289.   GetText(HWindow, id_Ed1, TGDI, SizeOf(TGDI));
  290.   GetText(HWindow, id_Ed2, TUSR, SizeOf(TUSR));
  291.   GetText(HWindow, id_Ed3, TMem, SizeOf(TMem));
  292.   StrCopy(Text,'');
  293.   StrCat(Text,TGDI);
  294.   StrCat(Text,TUSR);
  295.   StrCat(Text,TMem);
  296.     I := 0;
  297.       Len := StrLen(Text);
  298.       Valid := True;
  299.       while Valid and (I < Len) do
  300.       begin
  301.         Valid := Text[I] in NumSet;
  302.         Inc(I);
  303.       end;
  304.   if not Valid then
  305.       begin
  306.         MessageBeep(0);
  307.         MessageBox(Hwindow, 'Must enter Numbers only', 'Error', mb_Ok)
  308.         end else
  309.     begin
  310.     with DataPointer^ do
  311.         begin
  312.               GetText(HWindow,id_Ed1, GDIMin, SizeOf(GDIMin));
  313.               GetText(HWindow,id_Ed2, USRMin, SizeOf(USRMin));
  314.               GetText(HWindow,id_Ed3, MemMin, SizeOf(MemMin));
  315.         end;
  316.         TDialog.Ok(Msg);
  317.     end;
  318. end;
  319.  
  320. procedure TResourceApp.InitMainWindow;
  321. begin
  322.     MainWindow := New(PResourceWindow, Init(nil, 'Resource Monitor'));
  323. end;
  324.  
  325.  
  326. procedure TResourceWindow.WMDestroy(var Msg:TMessage);
  327. begin
  328.     KillTimer(HWindow,20);
  329.     TWindow.WMDestroy(Msg);
  330. end;
  331.  
  332. procedure TResourceWindow.WMSysCommand(var Msg:TMessage);
  333. begin
  334.     case Msg.WParam of
  335.         sc_About    :    About;
  336.         sc_Options    :    Options;
  337.     else
  338.         DefWndProc(Msg);
  339.     end;
  340. end;
  341.  
  342. procedure TResourceWindow.About;
  343. var Dialog:TDialog;
  344. begin
  345.     Application^.ExecDialog(New(PDialog,Init(@Self,'ABOUT')));
  346. end;
  347.  
  348. procedure TResourceWindow.Options;
  349. begin
  350.     Application^.ExecDialog(New(PEdDialog,Init(@Self,'OPTIONS',@DialogData)));
  351. end;
  352.  
  353. var
  354.     ResourceApp: TResourceApp;
  355.  
  356. begin
  357.     CmdShow:=sw_Minimize;
  358.     ResourceApp.Init('ResourceApp');
  359.     ResourceApp.Run;
  360.     ResourceApp.Done;
  361. end.
  362.